The Atari Compendium/The Atari Compendium (Toad Computers) (1994).iso/files/prgtools/modula2/module/bliste.mod

Modula Implementation | 1995-11-25 | 5.4 KB | 237 lines

IMPLEMENTATION MODULE  BListe;

FROM SYSTEM IMPORT TSIZE;
FROM Storage IMPORT ALLOCATE,DEALLOCATE;

TYPE List               = POINTER TO ListHeader;
     ListElementPointer = POINTER TO ListElement;
     ListHeader         = RECORD
                             current,
                             first,last : ListElementPointer;
                          END ;
     ListElement        = RECORD
                             next,prev     : ListElementPointer;
                             value         : Kunde
                          END(*RECORD*);


PROCEDURE MakeList(VAR L:List);
BEGIN
   ALLOCATE(L,TSIZE(ListHeader));
   L^.first:=NIL;
   L^.last:=NIL;
   L^.current:=NIL;
END MakeList;

PROCEDURE KillList(VAR L:List);
VAR p,q:ListElementPointer;
BEGIN
    p:=L^.first;
    WHILE (p#NIL) DO
      q:=p;
      p:=p^.next;
      DEALLOCATE(q);
    END(*WHILE*);
    DEALLOCATE(L);
    L:=NIL
END KillList;

PROCEDURE First(VAR L:List);
BEGIN
    L^.current:=L^.first;
END First;

PROCEDURE Last(VAR L:List);
BEGIN
    L^.current:=L^.last;
END Last;

PROCEDURE Next(VAR L:List);
BEGIN
   IF (~Empty(L) AND (L^.current^.next # NIL))THEN
      L^.current:=L^.current^.next;
   END(*IF*);
END Next;

PROCEDURE Prev(VAR L:List);
BEGIN
   IF (~Empty(L) AND (L^.current^.prev # NIL))THEN
      L^.current:=L^.current^.prev;
   END(*IF*);
END Prev;

PROCEDURE Empty(VAR L:List):BOOLEAN;
BEGIN
   RETURN L^.first=NIL
END Empty;

PROCEDURE AtFirst(VAR L:List):BOOLEAN;
BEGIN
   RETURN L^.current=L^.first
END AtFirst;

PROCEDURE AtLast(VAR L:List):BOOLEAN;
BEGIN
   RETURN L^.current=L^.last
END AtLast;

PROCEDURE Find(VAR L:List;VAR Value:Kunde; VAR Finde:VglProc; Key:Kunde ):BOOLEAN;
VAR OK :BOOLEAN;
BEGIN
    IF ~Empty(L) THEN
       LOOP
          OK:=GetValue(L,Value);
          IF Finde(Value,Key) THEN
             RETURN TRUE
          ELSE
              IF AtLast(L) THEN
                    RETURN FALSE
              END(*IF*);
              Next(L);
          END(*IF*);
       END(*LOOP*);
    ELSE
       RETURN FALSE
    END(*IF*);
END Find;

PROCEDURE FindFirst(VAR L:List;VAR Value:Kunde; VAR Finde:VglProc; Key:Kunde):BOOLEAN;
BEGIN
   IF ~Empty(L) THEN
      First(L);
      RETURN Find(L,Value,Finde,Key);
   ELSE
      RETURN FALSE
   END(*IF*);
END FindFirst;

PROCEDURE FindNext(VAR L:List;VAR Value:Kunde; VAR Finde:VglProc;Key:Kunde):BOOLEAN;
BEGIN
   IF ~Empty(L) THEN
      Next(L);
      RETURN Find(L,Value,Finde,Key);
   ELSE
      RETURN FALSE
   END(*IF*);
END FindNext;

PROCEDURE BubbleSort(VAR L:List;VAR Vgl:VglProc);
(* Vgl Proc liefert TRUE für Value1>Value2 *)
VAR Value1,Value2 : Kunde;
         OK, flag : BOOLEAN;
BEGIN
  IF ~Empty(L) THEN
      flag:= FALSE;
      WHILE ~flag DO
             Last(L);
             flag:= TRUE;
             WHILE ~AtFirst(L) DO
               OK:=GetValue(L,Value1);
               Prev(L);
               OK:=GetValue(L,Value2);
               IF Vgl(Value1,Value2) THEN
                  flag:=FALSE;
                  SetValue(L,Value1);
                  Next(L);
                  SetValue(L,Value2);
                  Prev(L);
               END(*IF*);
             END(*WHILE*);
      END(*WHILE*);
  END(*IF*);
END  BubbleSort;

PROCEDURE GetValue(VAR L:List;VAR Value :Kunde):BOOLEAN;
VAR i:INTEGER;
BEGIN
   IF ~Empty(L) THEN
         Value:=L^.current^.value;
     RETURN TRUE
   ELSE
     RETURN FALSE
   END(*IF*);
END GetValue;

PROCEDURE SetValue(VAR L:List;Value :Kunde);
VAR  i:INTEGER;
BEGIN
   IF ~Empty(L) THEN
         L^.current^.value:=Value;
   END(*IF*);
END SetValue;

PROCEDURE EnterElement(VAR L:List);
VAR p,q :ListElementPointer;
BEGIN
   ALLOCATE(p,TSIZE(ListElement));
   IF Empty(L) THEN
         L^.first:=p;
         L^.last:=p;
         p^.next:=NIL;
         p^.prev:=NIL;
   ELSIF AtFirst(L) THEN
         p^.next:=L^.first;
         L^.first:=p;
         p^.prev:=NIL;
         L^.current^.prev:=p;
   ELSE
         p^.next:=L^.current;
         p^.prev:=L^.current^.prev;
         q:=L^.current^.prev;
         q^.next:=p;
         L^.current^.prev:=p;
  END(*IF*);
  L^.current:=p;
END EnterElement;

PROCEDURE AppendElement(VAR L:List);
VAR p,q :ListElementPointer;
BEGIN
   ALLOCATE(p,TSIZE(ListElement));
   IF Empty(L) THEN
         L^.first:=p;
         L^.last:=p;
         p^.next:=NIL;
         p^.prev:=NIL;
   ELSIF AtLast(L) THEN
         p^.prev:=L^.last;
         L^.last:=p;
         p^.next:=NIL;
         L^.current^.next:=p;
   ELSE
         p^.next:=L^.current^.next;
         p^.prev:=L^.current;
         q:=L^.current^.next;
         q^.prev:=p;
         L^.current^.next:=p;
  END(*IF*);
  L^.current:=p;
END AppendElement;

PROCEDURE RemoveElement(VAR L:List);
VAR p,q :ListElementPointer;
BEGIN
   IF ~Empty(L) THEN
   p:=L^.current;
   IF (AtFirst(L) AND AtLast(L)) THEN
       L^.first:=NIL;
       L^.last:=NIL;
       L^.current:=NIL;
   ELSIF AtFirst(L) THEN
       L^.first:=L^.current^.next;
       L^.first^.prev:=NIL;
       L^.current:=L^.current^.next;
   ELSIF AtLast(L) THEN
       L^.last:=L^.current^.prev;
       L^.last^.next:=NIL;
       L^.current:=L^.current^.prev;
   ELSE
       p^.prev^.next:=p^.next;
       p^.next^.prev:=p^.prev;
       L^.current:=L^.current^.next;
   END(*IF*);
   DEALLOCATE(p);
   END(*IF*);
END RemoveElement;
END BListe.